home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / BLIB.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  30KB  |  1,013 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "libhdr.h"
  14. #include "vars.h"
  15. #include "segment.h"
  16. #include "gvars.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "ifile.h"
  20. #include "axqrp.h"
  21. #include "genp.h"
  22. #include "segmentp.h"
  23. #include "ginterp.h"
  24. #include "setp.h"
  25. #include "bmainp.h"
  26. #include "gutilp.h"
  27. #include "dclmapp.h"
  28. #include "libp.h"
  29. #include "libfp.h"
  30. #include "librp.h"
  31. #include "glibp.h"
  32. #include "miscp.h"
  33. #include "gmiscp.h"
  34. #include "smiscp.h"
  35. #include "gnodesp.h"
  36. #include "blibp.h"
  37.  
  38. static void update_elaborate(char *);
  39. static void main_code_segment();
  40. static Tuple delayed_map_get(int);
  41. static void delayed_map_put(int, Tuple);
  42. static void delayed_map_undef(int);
  43. static void add_code(char *);
  44. static int needs_body_bnd(char *);
  45. static int depth_level(char *);
  46. static Tuple build_relay_sets(char *, int);
  47. static void update_subunit_context(char *);
  48. static int load_binding_unit(char *);
  49. static char *read_binding_ais(char *, char *);
  50.  
  51. extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
  52. extern int adacomp_option;
  53. extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
  54. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  55. extern IFILE *AXQFILE, *LIBFILE, *AISFILE, *STUBFILE;
  56.  
  57. /* variables used only by binder */
  58. static Symbol    mainunit_sym;
  59.  
  60. int binder(Tuple aisread_tup)                                    /*;binder*/
  61. {
  62.     /*
  63.      * BINDER checks the program library of a given main program for
  64.      * completeness.  Missing modules are printed.
  65.      * Otherwise, idle_task and main_task are generated. idle_task calls
  66.      * the initialization procedures required to elaborate the various
  67.      * units in (one of) the order(s) prescribed by the language
  68.      */
  69.  
  70.     char    *name, *body, *main_name, *s_name;
  71.     int        prior, unit, name_num, delayed_unit;
  72.     Set        elaborated, idle_precedes, precedes;
  73.     struct unit *pUnit;
  74.     Tuple    missing_units, to_check, to_bind, u_slots, tup;
  75.     Tuple    elaboration_table, compiled_units, delayed, s, u_rs;
  76.     Fortup    ft1;
  77.     Forset    fs1;
  78.     Unitdecl    ud;
  79.     int        i, n;
  80.     int         is_interfaced_bind_unit_now;
  81.  
  82. #ifdef DEBUG
  83.     Tuple       axq_needed; /* list of predefined units */
  84. #endif
  85.  
  86.     /* Reset global tuple of node and symbols for binder. */
  87.     seq_node_n = 0;
  88.     seq_node = tup_new(SEQ_NODE_INC);
  89.     seq_symbol_n = 0;
  90.  
  91.     /*  Miscelleanous variables needed for code generation */
  92.     LOCAL_REFERENCE_MAP =  local_reference_map_new();
  93.     RELAY_SET = tup_new(0);
  94.     /*
  95.      * POSITION and PATCHES is stored in EMAP and is set implicitly when a new
  96.      * EMAP is created for a symbol and therefore is not needed here.
  97.      *
  98.      * POSITION     = {};
  99.      * PATCHES     = {};
  100.      */
  101.     CURRENT_LEVEL = 0;
  102.     LAST_OFFSET     = 0;
  103.     MAX_OFFSET     = 0;
  104.  
  105.     call_lib_unit = tup_new(0);
  106.  
  107.     if (streq(MAINunit, "")) {
  108.         to_check = tup_new(0);
  109.         /* collect all possible main units i.e. all parameterless subprograms
  110.          * which are not proper bodies (subunits).
  111.          */
  112.         for (i = 15; i <= unit_numbers; i++) {
  113.             struct unit *pUnit = pUnits[i];
  114.             if (pUnit->isMain && !streq("ma", unit_name_type(pUnit->name)))
  115.                 to_check = tup_with(to_check,pUnit->name);
  116.         }
  117.         if (tup_size(to_check) == 0) {
  118.             user_error("No subprogram in library");
  119.             return FALSE;
  120.         }
  121.         else if (tup_size(to_check) == 1) {
  122.             main_name = tup_frome(to_check);
  123.             MAINunit  = unit_name_name(main_name);
  124.         }
  125.         else {
  126.             user_error(
  127.                   "Several subprograms in library please specify main from:");
  128.             FORTUP(name = (char *), to_check, ft1);
  129.                 user_info(unit_name_name(name));
  130.             ENDFORTUP(ft1);
  131.             return FALSE;
  132.         }
  133.     }
  134.     else {
  135.         main_name = strjoin("su", MAINunit);
  136.     }
  137.  
  138.     if (!load_binding_unit(main_name)) {
  139.         /* message cannot retrieve... already printed */
  140.         return FALSE;
  141.     }
  142.     update_elaborate(main_name);
  143.     ud = unit_decl_get(main_name);
  144.     mainunit_sym = ud->ud_unam;
  145.     if (NATURE(mainunit_sym) != na_procedure    /* only procedures */
  146.       || tup_size(SIGNATURE(mainunit_sym)) != 0) {    /* without parameters */
  147.         user_error(strjoin(formatted_name(main_name),
  148.           " is not a valid main program."));
  149.         return FALSE;
  150.     }
  151.     name  = strjoin(MAINunit, "_idle_task");
  152.     /* The name of the binding unit is "ma" followed by the name */
  153.     /* In SETL unit_name was ['main_unit', name] */
  154.     /* Note that this may create a new unit */
  155.     unit_name      = strjoin("ma", name);
  156.     unit_number_now  = unit_number(unit_name);
  157.     lib_unit_put(unit_name, AISFILENAME);
  158.  
  159.     /*    Symbol table initialized with 'main_task_type' */
  160.  
  161.     symbol_main_task_type = sym_new(na_task_type);
  162.     TYPE_OF(symbol_main_task_type) = symbol_main_task_type;
  163.     SIGNATURE(symbol_main_task_type) = tup_new(0);
  164.     ALIAS(symbol_main_task_type) = symbol_main_task_type;
  165.     ORIG_NAME(symbol_main_task_type) = "main_task_type";
  166.     DECLARED(symbol_main_task_type) = dcl_new(0);
  167.     TYPE_KIND(symbol_main_task_type) = TK_WORD;
  168.     TYPE_SIZE(symbol_main_task_type) = su_size(TK_WORD);
  169. #ifdef TBSL
  170.     /* REFERENCE_MAP = {['main_task_type', [1, 47]]}; */
  171.     S_SEGMENT(symbol_main_task_type) = 1;
  172.     S_OFFSET(symbol_main_task_type)  = 47;
  173. #endif
  174.     MISC(symbol_main_task_type) = (char *)TRUE;
  175.  
  176.     /* Here we duplicate that part of the code from init_gen needed
  177.      * when starting a new unit
  178.      *
  179.      * Set initial unit_slots map to null value 
  180.      * assume unit_number_now gives curent unit number; the correct
  181.      * assignment of this may best be done elsewhere
  182.      */
  183.     tup = tup_new(5);
  184.     for (i = 1; i <= 5; i++)
  185.         tup[i] = (char *) tup_new(0);
  186.     unit_slots_put(unit_number_now, tup);
  187.     to_check      = tup_new1(main_name);
  188.     idle_precedes  = set_new1((char *) unit_numbered(main_name));
  189.     to_bind      = tup_new(0);
  190.     missing_units  = tup_new(0);
  191.     compiled_units = tup_new(unit_numbers);
  192.     for (i = 1; i <= unit_numbers; i++)
  193.         compiled_units[i] = pUnits[i]->libUnit;
  194.  
  195.     /* check that any needed unit has been compiled. 
  196.      *
  197.      * All units needed (directly or indirectly) by main_name are checked. 
  198.      * The order in which these checks are performed is unimportant. The 
  199.      * ordering map 'precedes' has been loaded from library, for later use 
  200.      * in a topological sort. 
  201.      *
  202.      * All units needed, but not referenced by with clauses (typically 
  203.      * package bodies, procedure bodies and subunits) are noted into 
  204.      * idle_precedes to make later idle_task depend on them, in order to 
  205.      * suppress the binding unit if they are recompiled. 
  206.      */
  207.  
  208.     while (tup_size(to_check)!= 0) {
  209.  
  210.         /* always load the item at the front of the queue so that specs are
  211.          * read before their bodies.
  212.          * TBSL: this is due to the fact that the body sometimes contains
  213.          * info that is not in the spec(e.g. ASSOC_SYMBOLS) and since they share
  214.          * the same symbol the info would be overridden by the spec if the spec 
  215.          * was read last.
  216.          */
  217.         name = tup_fromb(to_check);
  218.         if (is_generic(name))
  219.             continue;
  220.  
  221.         /* Check to see whether a package specification requires a body and
  222.          * if yes, that the body has been compiled.
  223.          */
  224.         if (streq(unit_name_type(name), "sp")
  225.           || streq(unit_name_type(name), "bo")) {
  226.             /* AXQ needed */
  227.             if (!load_binding_unit(name))
  228.                 missing_units = tup_with(missing_units, name);
  229.             else
  230.                 update_elaborate(name);
  231.         }
  232.         /* Collect the stubs of the current unit. */
  233.         s = stubs(name);
  234.         /*
  235.          * to_check      +:= s;
  236.          * missing_units +:= s - compiled_units;  
  237.          * idle_precedes +:= s;
  238.          */
  239.         FORTUP(s_name = (char *), s, ft1);
  240.              if (!tup_memstr(s_name, to_check))
  241.                  to_check = tup_with(to_check, s_name);
  242.              if (!tup_memstr(s_name, compiled_units))
  243.                  missing_units = tup_with(missing_units, s_name);
  244.              idle_precedes = set_with(idle_precedes,
  245.                (char *) unit_numbered(s_name));
  246.         ENDFORTUP(ft1);
  247.  
  248.         if (streq(unit_name_type(name), "sp")) {
  249.             body = strjoin("bo", unit_name_name(name));
  250.             if (tup_memstr(body, compiled_units)) {
  251.                 to_check = tup_with(to_check, body);
  252.                 idle_precedes = set_with(idle_precedes,
  253.                   (char *)unit_numbered(body));
  254.             }
  255.             else if (needs_body_bnd(name))
  256.                 missing_units = tup_with(missing_units, body);
  257.         }
  258.         else if (streq(unit_name_type(name), "ss")) {
  259.             /* Suprogram body must be present.*/
  260.             body = strjoin("su", unit_name_name(name));
  261.             if (tup_memstr(body, compiled_units) && load_binding_unit(body)) {
  262.